mbpls.ktab <-
function (X, Y, option = c("inertia", "lambda1", "uniform", "internal"), 
    deflation = c("super", "block"), nf = 3, tol = 1e-06, max.iter = 100, 
    ...) 
{
print("In construction!!!  problem with weighting!!!")
    if (!inherits(X, "ktab")) 
        stop("object 'ktab' expected")
    if (!inherits(Y, "dudi")) 
        stop("object 'dudi' expected")
    lw <- X$lw
    if (all(lw != Y$lw)) 
        stop("non convient arguments!")
    Iner <- function(x) sum(svd(x)$d^2)
    nlig <- length(lw)
    cw <- X$cw
    ncol <- length(cw)
    nbloc <- length(X$blo)
    bloc <- X$blo
    indicablo <- X$TC[, 1]
    Xsepan <- sepan(X, nf = 4)
    rank.fac <- factor(rep(1:nbloc, Xsepan$rank))
    tabw <- NULL
    auxinames <- ktab.util.names(X)
    if (option == "lambda1") {
        for (i in 1:nbloc) tabw <- c(tabw, 1/Xsepan$Eig[rank.fac == 
            i][1])
    }
    else if (option == "inertia") {
        for (i in 1:nbloc) tabw <- c(tabw, 1/sum(Xsepan$Eig[rank.fac == 
            i]))
    }
    else if (option == "uniform") {
        tabw <- rep(1, nbloc)
    }
    else if (option == "internal") 
        tabw <- X$tabw
    else stop("Unknown option")
    for (i in 1:nbloc) {
        X[[i]] <- X[[i]] * sqrt(tabw[i])
    }
    InerX <- rep(NA, length(bloc))
    Xtemp <- unclass(X)[1:nbloc]
    for (i in 1:nbloc) {
        Xtemp[[i]] <- Xtemp[[i]] * sqrt(X$lw)
        Xtemp[[i]] <- t(t(Xtemp[[i]]) * sqrt(X$cw[X$TC[, 1] == 
            i]))
        InerX[i] <- Iner(Xtemp[[i]])
    }
    Ytemp <- Y$tab
    Ytemp <- Ytemp * sqrt(Y$lw)
    Ytemp <- t(t(Ytemp) * sqrt(Y$cw))
    InerY <- Iner(Ytemp)
    Tt <- list()
    Tb <- list()
    Qt <- list()
    Pb <- list()
    U <- list()
    Wb <- list()
    Wt <- list()
    ExpVarX <- matrix(rep(X$blo, nf), ncol = nf, nrow = length(X$blo))
    ExpVarY <- rep(NA, nf)
    hiter <- NULL
    for (h in 1:nf) {
        u <- Ytemp[, 1]
        iter <- 1
        tt.old <- 0
        repeat {
            wb <- list()
            tb <- list()
            for (k in 1:nbloc) {
                w <- t(Xtemp[[k]]) %*% (u/drop(crossprod(u)))
                w <- w/sqrt(drop(crossprod(w)))
                wb[[k]] <- w
                tb[[k]] <- as.matrix(Xtemp[[k]]) %*% w
            }
            T <- do.call("cbind", tb)
            wt <- t(T) %*% (u/drop(crossprod(u)))
            wt <- wt/sqrt(drop(crossprod(wt)))
            tt <- T %*% (wt/drop(crossprod(wt)))
            q <- t(Ytemp) %*% (tt/drop(crossprod(tt)))
            u <- as.matrix(Ytemp) %*% (q/drop(crossprod(q)))
            if (crossprod(tt - tt.old) < tol) 
                break
            if (iter == max.iter) {
                warning(paste("Maximum number of iterations reached for dimension", 
                  h), call. = FALSE)
                break
            }
            tt.old <- tt
            iter <- iter + 1
        }
        hiter <- c(hiter, iter)
        if (deflation == "block") {
            pb <- list()
            for (k in 1:nbloc) {
                pb[[k]] <- t(Xtemp[[k]]) %*% (tb[[k]]/drop(crossprod(tb[[k]])))
                Xtemp[[k]] <- as.matrix(Xtemp[[k]]) - as.matrix(tb[[k]]) %*% 
                  t(as.matrix(pb[[k]]))
                ExpVarX[k, h] <- 1 - Iner(Xtemp[[k]])/InerX[[k]]
            }
            Ytemp <- as.matrix(Ytemp) - as.matrix(tt) %*% t(q)
            ExpVarY[h] <- 1 - Iner(Ytemp)/InerY
        }
        else if (deflation == "super") {
            pb <- list()
            for (k in 1:nbloc) {
                pb[[k]] <- t(Xtemp[[k]]) %*% (tt/drop(crossprod(tt)))
                Xtemp[[k]] <- as.matrix(Xtemp[[k]]) - as.matrix(tt) %*% 
                  t(as.matrix(pb[[k]]))
                ExpVarX[k, h] <- 1 - Iner(Xtemp[[k]])/InerX[[k]]
            }
            Ytemp <- as.matrix(Ytemp) - as.matrix(tt) %*% t(q)
            ExpVarY[h] <- 1 - Iner(Ytemp)/InerY
        }
        else stop("non convenient deflation method!")
        Tt[[h]] <- tt
        Qt[[h]] <- q
        Pb[[h]] <- unlist(pb)
        Tb[[h]] <- unlist(tb)
        U[[h]] <- u
        Wb[[h]] <- unlist(wb)
        Wt[[h]] <- wt
    }
    Tt <- do.call("cbind", Tt)
    Qt <- do.call("cbind", Qt)
    U <- do.call("cbind", U)
    Wt <- do.call("cbind", Wt)
    Wb <- do.call("cbind", Wb)
    Pb <- do.call("cbind", Pb)
    Tb <- do.call("cbind", Tb)
    res <- list(Tt, Qt, Wt, Pb, U, Wb, Tb, hiter, X$TC, X$TL)
    names(res) <- c("Tt", "Qt", "Wt", "Pb", "U", "Wb", "Tb", 
        "iter", "TC", "TL")
    res$Y <- Y$tab
    res$X <- X[1:nbloc]
    res$InerY <- InerY
    res$InerX <- InerX
    res$ExpVarX <- ExpVarX
    res$ExpVarY <- ExpVarY
    res$blo <- bloc
    res$Xnames <- auxinames
res$option <- option
res$deflation <- deflation
    res$class <- "mbpls"
    res$call <- match.call()
    return(res)
}
